home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / compiler-driver.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  17.4 KB  |  523 lines  |  [TEXT/CCL2]
  1. ;;; compiler-driver.scm -- compilation unit management
  2. ;;;
  3. ;;; author :  John & Sandra
  4. ;;;
  5. ;;;
  6.  
  7.  
  8. ;;; Flags for controlling various low-level behaviors of the compiler.
  9. ;;; You might want to tweak these in the system-building scripts for
  10. ;;; different Lisps, but users don't normally need to mess with them.
  11.  
  12. (define *compile-interface* '#f)
  13. (define *interface-code-quality* 2)
  14. (define *interface-chunk-size* '#f)
  15. (define *default-code-quality* 2)
  16. (define *optimized-code-quality* 3)
  17. (define *code-chunk-size* 300)
  18.  
  19. ;;; File extension definitions
  20.  
  21. (define *source-file-extensions* '(".hs" ".lhs"))
  22. (define *unit-file-extension* ".hu")
  23. (define *interface-file-extensions* '(".hi" ".lhi"))
  24. (define *lisp-file-extensions* '(".lisp" ".scm"))
  25. (define *foreign-object-file-extensions* '(".o"))
  26.  
  27. ;;; Other stuff
  28.  
  29. (define *unit-stack* '())    ; used to detect circular dependencies
  30. (define *units-loaded* '())  ; used to detect units already loaded
  31.  
  32.  
  33.  
  34. ;;;=====================================================================
  35. ;;; Main entry point
  36. ;;;=====================================================================
  37.  
  38. ;;; This is the top level driver for the compiler.  It takes a file name
  39. ;;; and output controls.
  40.  
  41. (define (haskell-compile filename cflags)
  42.   ;; used to detect circular loads
  43.   (setf (dynamic *unit-stack*) '())
  44.   ;; used to avoid reloading previously loaded units
  45.   (setf (dynamic *units-loaded*) '())
  46.   (initialize-haskell-system)
  47.   (let ((unit (load-compilation-unit
  48.            (add-extension filename *unit-file-extension*)
  49.            cflags)))
  50.     ;; This checks for interfaces which have no implementations
  51.     (setf *implementations-needed* '())
  52.     (table-for-each (lambda (mod-name mod)
  53.               (when (and (memq (module-type mod)
  54.                        '(interface psuedo-interface))
  55.                  (not (module-stand-alone? mod)))
  56.              (push mod-name *implementations-needed*)))
  57.               *modules*)
  58.     (setf *current-initcode* (ucache-initcode unit))
  59.     (unless (null? *implementations-needed*)
  60.       (format '#t
  61.         "Evaluation disabled in this unit.~%~
  62.          Implementations needed for module(s) ~A~%"
  63.     (show-symbol-list/no-downcase *implementations-needed*)))
  64.     ;; Do NOT mess with the return value from this function.
  65.     ;; The command interface relies on this return value.
  66.     unit))
  67.  
  68.  
  69. ;;;=====================================================================
  70. ;;; Guts
  71. ;;;=====================================================================
  72.  
  73.  
  74. ;;; This is the main entry to the compilation system.  This causes a
  75. ;;; unit to be compiled and/or loaded.  All units are initially marked as
  76. ;;; available.
  77.  
  78. ;;; When a unit is not in the cache, it is created by the parser.
  79.  
  80. (define (load-compilation-unit filename cflags)
  81.   (let ((cunit (lookup-compilation-unit filename)))
  82.     (cond ((eq? cunit '#f)
  83.        ;; Unit not found in cache.
  84.        (load-compilation-unit-aux
  85.          (parse-compilation-unit filename) cflags))
  86.       ;; Is unit already loaded?
  87.       ((memq cunit (dynamic *units-loaded*))
  88.        cunit)
  89.       ;; Is the unit in the process of loading??
  90.       ((memq cunit (dynamic *unit-stack*))
  91.        (signal-circular-unit filename))
  92.       (else
  93.        ;; Reload unit from cache.
  94.        (load-compilation-unit-aux cunit cflags)))))
  95.  
  96.  
  97. ;;; This is the basic treatment of compilation units.  Push onto stack
  98. ;;; to detect circularities.  Load all imported units and then
  99. ;;; decide whether to
  100. ;;;   a) pull the unit out of the unit cache
  101. ;;;   b) load previously compiled code
  102. ;;;   c) recompile from scratch
  103. ;;; Full recompilation is required when either a source file is out of date
  104. ;;; or the compiled files are out of date or an new output file needs to be
  105. ;;; written.
  106. ;;;
  107.  
  108. (define (load-compilation-unit-aux c cflags)
  109.   (dynamic-let ((*unit-stack*  (cons c (dynamic *unit-stack*))))
  110.     ;; Load all the imported units first.
  111.    (let ((imported-units
  112.        (map (lambda (filename) (load-compilation-unit filename cflags))
  113.         (ucache-imported-units c))))
  114.      (cond ((unit-already-loaded? c cflags)
  115.        ;; An up-to-date version of this unit has already been loaded.
  116.        'no-action)
  117.       ((unit-already-compiled? c cflags)
  118.        ;; Load the previously compiled unit.
  119.        (load-compiled-unit c (cflags-load-code? cflags) imported-units))
  120.       (else
  121.        ;; Recompile the unit.
  122.        (locally-compile c cflags imported-units)))
  123.     (push c (dynamic *units-loaded*))
  124.     ;; Hack, hack.  When loading the prelude, make sure magic symbol
  125.     ;; table stuff is initialized.
  126.     (when (string=? (ucache-ufile c) *prelude-unit-filename*)
  127.       (init-prelude-globals))
  128.     c)))
  129.  
  130.  
  131. ;;; This brings in a previously compiled unit.  Everything is up to date at
  132. ;;; this point.
  133.  
  134. (define (load-compiled-unit c load-code? imported-units)
  135.   (setf (dynamic *init-complete*) '#f)
  136.   (initialize-module-table)
  137.   (dolist (u imported-units)
  138.      (add-modules-to-environment (ucache-modules u)))
  139.   (when (and load-code? (not (ucache-code-loaded c)))
  140.     (when (memq 'loading *printers*)
  141.       (format '#t "~&Loading ~s.~%" (ucache-ufile c))
  142.       (force-output))
  143.     (load-lisp-files c)
  144.     (load-foreign-files c)
  145.     (dynamic-let ((*initcode-function*  '#f))
  146.       ;; choose the compiled code if available
  147.       (cond ((valid-compiled-codefiles-written? c)
  148.            (load (ucache-cfile c))
  149.           (setf (ucache-code-compiled c) '#t))
  150.         (else
  151.          (load (ucache-sfile c))
  152.          (setf (ucache-code-compiled c) '#f)))
  153.       (if (dynamic *initcode-function*)
  154.       (setf (ucache-initcode c) 
  155.         (combine-initcode imported-units (dynamic *initcode-function*)))
  156.       (error "No initcode defined in this file!"))
  157.       (setf (ucache-code-loaded c) '#t)))
  158.   (when (not (ucache-ifile-loaded c))
  159.      (read-binary-interface c)
  160.      (setf (ucache-ifile-loaded c) '#t))
  161.   (mark-conflicting-code c)
  162.   (setf (ucache-modules c) (get-all-modules)))
  163.  
  164. ;;; Load or compile lisp files.
  165.  
  166. (define (load-lisp-files u)
  167.   (dolist (f (ucache-lisp-files u))
  168.      (load-more-recent-file (cdr f) (car f))))
  169.  
  170. (define (compile-lisp-files u)
  171.   (dolist (f (ucache-lisp-files u))
  172.     (let ((source  (car f))
  173.       (binary  (cdr f)))
  174.       (when (not (lisp-binary-current source binary))
  175.     (compile-file source binary))
  176.       (load binary))))
  177.  
  178. (define (load-foreign-files u)
  179.   (dolist (f (ucache-foreign-files u))
  180.     (if (file-exists? f)
  181.     (load-foreign-file/cached f)
  182.     (fatal-error 'missing-object-file "File ~A not found." f))))
  183.  
  184. ;;; This determines whether the unit is already loaded and ready to go.
  185. ;;; The interface and code (if desired) must be present and the unit
  186. ;;; must either be stable or completely up to date with sources and
  187. ;;; imports.
  188.  
  189. (define (unit-already-loaded? c cflags)
  190.   (or (and (ucache-stable? c)
  191.        (ucache-code-loaded c)
  192.        (ucache-ifile-loaded c))
  193.       (and (ucache-ifile-loaded c)
  194.        (or (not (cflags-load-code? cflags))
  195.            (and (ucache-code-loaded c)
  196.             (or (ucache-code-compiled c)
  197.             (not (cflags-compile-code? cflags)))))
  198.        (everything-current? c)
  199.        (output-files-ok c cflags))))
  200.  
  201. (define (everything-current? c)
  202.   (let ((udate  (ucache-udate c)))
  203.     (and (all-imports-current (ucache-imported-units c) udate)
  204.      (all-sources-current (ucache-source-files c) udate)
  205.      (all-lisp-sources-current (ucache-lisp-files c) udate))))
  206.  
  207. (define (all-sources-current sources unit-write-date)
  208.   (every (lambda (s)
  209.        (let ((d  (file-write-date s)))
  210.          (and d (>= unit-write-date d))))
  211.      sources))
  212.  
  213. (define (all-imports-current imports unit-write-date)
  214.   (every (lambda (s)
  215.          (let ((u (lookup-compilation-unit s)))
  216.            (or (ucache-stable? u)
  217.            (>= unit-write-date (ucache-udate u)))))
  218.      imports))
  219.  
  220. (define (all-lisp-sources-current lisp-files unit-write-date)
  221.   (every (lambda (s)
  222.        (let ((d  (file-write-date (car s))))
  223.          (and d (>= unit-write-date d))))
  224.      lisp-files))
  225.  
  226. ;;; This determines whether all required output files are already present and
  227. ;;; up to date.
  228.  
  229. (define (output-files-ok u cflags)
  230.  (or
  231.   (not (cflags-write-code? cflags))   ; must want to write an output file
  232.   (and (valid-interface-written? u)
  233.        (if (cflags-compile-code? cflags)
  234.        (valid-compiled-codefiles-written? u)
  235.        (valid-codefiles-written? u)))))
  236.  
  237. (define (valid-interface-written? u)
  238.   (or 
  239.       (and (file-exists? (ucache-cifile u))
  240.        (>= (file-write-date (ucache-cifile u)) (ucache-udate u)))
  241.       (and (file-exists? (ucache-sifile u))
  242.        (>= (file-write-date (ucache-sifile u)) (ucache-udate u)))))
  243.  
  244. ;;; Fudge a little here and assume that lisp files are also compiled
  245. ;;; and present of compiled codefile is present.
  246.  
  247. (define (valid-compiled-codefiles-written? u)
  248.   (and (file-exists? (ucache-cfile u))
  249.        (>= (file-write-date (ucache-cfile u)) (ucache-udate u))))
  250.  
  251. (define (valid-uncompiled-codefiles-written? u)
  252.   (and (file-exists? (ucache-sfile u))
  253.        (>= (file-write-date (ucache-sfile u)) (ucache-udate u))))
  254.  
  255. (define (valid-codefiles-written? u)
  256.   (or (valid-compiled-codefiles-written? u)
  257.       (valid-uncompiled-codefiles-written? u)))
  258.  
  259.  
  260. ;;; To make use of a previously compiled unit, we need the interface
  261. ;;; (either in memory or in a file), all desired output files, and possibly
  262. ;;; a code file.
  263.  
  264. (define (interface-unit? c)
  265.  (let ((sources (ucache-source-files c)))
  266.    (and (pair? sources) (null? (cdr sources))
  267.     (interface-extension? (filename-type (car sources))))))
  268.  
  269. (define (unit-already-compiled? c cflags)
  270.   (setup-unit-date c)
  271.   (setf (ucache-ifile-loaded c) '#f)
  272.   (setf (ucache-code-loaded c) '#f)
  273.   (and (valid-interface-written? c)
  274.        (output-files-ok c cflags)
  275.        (or (not (cflags-load-code? cflags))
  276.        (if (cflags-compile-code? cflags)
  277.            (valid-compiled-codefiles-written? c)
  278.            (valid-codefiles-written? c)))))
  279.  
  280. (define (all-lisp-binaries-current lisp-files)
  281.   (every (lambda (s)
  282.        (lisp-binary-current (car s) (cdr s)))
  283.      lisp-files))
  284.  
  285. (define (lisp-binary-current source binary)
  286.   (and (file-exists? binary)
  287.        (let ((sd  (file-write-date source))
  288.          (bd  (file-write-date binary)))
  289.      (and sd bd (> bd sd)))))
  290.  
  291.  
  292. ;;; This does the actual job of compilation.
  293.  
  294. (define (locally-compile c cflags imported-units)
  295.   (setf (dynamic *init-complete*) '#f)
  296.   (dynamic-let ((*printers*
  297.           (if (ucache-printers-set? c)
  298.               (ucache-printers c)
  299.               (dynamic *printers*)))
  300.         (*optimizers*
  301.           (if (ucache-optimizers-set? c)
  302.               (ucache-optimizers c)
  303.               (if (cflags-compile-code? cflags)
  304.               (dynamic *compiled-code-optimizers*)
  305.               (dynamic *interpreted-code-optimizers*))))
  306.         (*initcode-function-name*
  307.           (string->symbol (format '#f "Initcode for unit ~s"
  308.                       (ucache-ufile c))))
  309.         (*initcode-function*
  310.           '#f))
  311.     (when (memq 'compiling *printers*)
  312.        (format '#t "~&Compiling  ~s [~A]~%"
  313.            (ucache-ufile c)
  314.            (show-symbol-list *optimizers*))
  315.        (force-output))
  316.     (initialize-module-table)
  317.     (dolist (u imported-units)
  318.       (add-modules-to-environment (ucache-modules u)))
  319.     (if (cflags-compile-code? cflags)
  320.     (compile-lisp-files c)
  321.     (load-lisp-files c))
  322.     (load-foreign-files c)
  323.     (multiple-value-bind (mods code)
  324.     (compile-haskell-files (ucache-source-files c))
  325.       ;; General bookkeeping to update module interface in cache.
  326.       (setup-ucache-modules c mods)
  327.       (setf (ucache-code-compiled c) (cflags-compile-code? cflags))
  328.       (setf (ucache-modules c) (get-all-modules))
  329.       (setf (ucache-ifile-loaded c) '#t)
  330.       (setup-unit-date c)
  331.       ;; Write interface file if necessary.
  332.       (let ((interface? (interface-module? (car (ucache-modules c)))))
  333.        (when (cflags-write-interface? cflags)
  334.     (let ((phase-start-time (get-run-time))
  335.           (icode  (create-dump-code c mods (ucache-load-prelude? c))))
  336.       (if (dynamic *compile-interface*)
  337.           (write-compiled-code-file
  338.             (ucache-cifile c)
  339.         icode
  340.         (dynamic *interface-code-quality*)
  341.         (dynamic *interface-chunk-size*))
  342.           (write-interpreted-code-file (ucache-sifile c) icode '#f))
  343.       (when (memq 'phase-time *printers*)
  344.         (let* ((current-time (get-run-time))
  345.            (elapsed-time (- current-time phase-start-time)))
  346.           (format '#t "Interface complete: ~A seconds~%" elapsed-time)
  347.           (force-output)))))
  348.       ;; Write code file if necessary.
  349.        (when (and (cflags-write-code? cflags)
  350.           (or (not interface?)
  351.               (some (function module-stand-alone?) mods)))
  352.     (if (cflags-compile-code? cflags)
  353.         (write-compiled-code-file
  354.           (ucache-cfile c)
  355.           code
  356.           (if (memq 'lisp (dynamic *optimizers*))
  357.           (dynamic *optimized-code-quality*)
  358.           (dynamic *default-code-quality*))
  359.           (or (ucache-chunk-size c) (dynamic *code-chunk-size*)))
  360.         (write-interpreted-code-file (ucache-sfile c) code '#t)))
  361.       ;; Load or evaluate code if necessary.
  362.       ;; If we just wrote a compiled code file, load that; otherwise
  363.       ;; do eval or in-core compilation.
  364.       (when (cflags-load-code? cflags)
  365.     (if (and (cflags-write-code? cflags)
  366.          (cflags-compile-code? cflags)
  367.          (not interface?))
  368.         (load (ucache-cfile c))
  369.         (eval code (cflags-compile-code? cflags)))
  370.     (if (dynamic *initcode-function*)
  371.         (setf (ucache-initcode c)
  372.           (combine-initcode imported-units
  373.                     (dynamic *initcode-function*)))
  374.         (error "No initcode defined in this file!"))
  375.     (mark-conflicting-code c)
  376.     (setf (ucache-code-loaded c) '#t))
  377.       ))))
  378.  
  379. ;;; This marks all code associated with a module that shares a name with a
  380. ;;; just loaded module as 'non-loaded'.
  381.  
  382. (define (mark-conflicting-code c)
  383.   (let ((mods (ucache-modules-defined c)))
  384.     (for-all-cached-units
  385.      (lambda (m1)
  386.        (when (not (eq? m1 c))
  387.          (when (some (lambda (mod1)
  388.                (memq mod1 mods))
  389.              (ucache-modules-defined m1))
  390.         (when (ucache-stable? m1)
  391.               (haskell-warning 'redefinition-of-stable
  392.                 "Modules in stable unit ~A may be corrupted"
  393.         (ucache-ufile m1)))
  394.         (setf (ucache-code-loaded m1) '#f)))))))
  395.  
  396. ;;; This places a timestamp on the unit as determined by the timestamp of
  397. ;;; all imported units (which must be loaded & valid at this point)
  398. ;;; and all source files.
  399.  
  400. (define (setup-unit-date u)
  401.   (dolist (file (ucache-lisp-files u))
  402.     (freshen-unit-date u (file-write-date (tuple-2-1 file)))
  403.     (when (file-exists? (tuple-2-2 file))
  404.        (freshen-unit-date u (file-write-date (tuple-2-2 file)))))
  405.   (dolist (file (ucache-source-files u))
  406.     (freshen-unit-date u (file-write-date file)))
  407.   (dolist (i (ucache-imported-units u))
  408.     (let ((iu (lookup-compiled-unit i)))  ; must be in cache by now
  409.       (when (not (ucache-stable? iu))
  410.      (freshen-unit-date u (ucache-udate iu))))))
  411.  
  412. ;;; The date of a unit is the max of all constituant write dates.
  413. ;;; This freshens the date in a unit.
  414.  
  415. (define (freshen-unit-date u date)
  416.  (when date
  417.   (setf (ucache-udate u) (max (ucache-udate u) date))))
  418.  
  419.  
  420.  
  421. ;;;=====================================================================
  422. ;;; Filename utilities
  423. ;;;=====================================================================
  424.  
  425. ;;; File extensions
  426.  
  427. (define (source-extension? x)
  428.   (mem-string x *source-file-extensions*))
  429.  
  430. (define (unit-extension? x)
  431.   (string=? x *unit-file-extension*))
  432.  
  433. (define (interface-extension? x)
  434.   (mem-string x *interface-file-extensions*))
  435.  
  436. (define (lisp-extension? x)
  437.   (mem-string x *lisp-file-extensions*))
  438.  
  439. (define (foreign-extension? x)
  440.   (mem-string x *foreign-object-file-extensions*))
  441.  
  442.  
  443. ;;; Build file names.
  444.  
  445. (define (make-cifilename filename)
  446.   (let ((place  (filename-place filename))
  447.     (name   (string-append (filename-name filename) "-hci")))
  448.     (assemble-filename place name binary-file-type)))
  449.  
  450. (define (make-sifilename filename)
  451.   (let ((place  (filename-place filename))
  452.     (name   (string-append (filename-name filename) "-hci")))
  453.     (assemble-filename place name source-file-type)))
  454.  
  455. (define (make-cfilename filename)
  456.   (add-extension filename binary-file-type))
  457.  
  458. (define (make-sfilename filename)
  459.   (add-extension filename source-file-type))
  460.  
  461.  
  462. ;;; This take a file name (extension ignored) & searches for a source file.
  463.  
  464. (define (locate-existing-source-file name)
  465.   (locate-extension name *source-file-extensions*))
  466.  
  467. (define (locate-extension name extensions)
  468.   (if (null? extensions)
  469.       '#f
  470.       (let ((name-1 (add-extension name (car extensions))))
  471.     (if (file-exists? name-1)
  472.         name-1
  473.         (locate-extension name (cdr extensions))))))
  474.  
  475.  
  476. ;;; These globals save the Prelude symbol table to avoid copying it
  477. ;;; into all modules which use the Prelude.
  478.  
  479. ;;; Danger!  This assumes that every local symbol in the Prelude is
  480. ;;; exported.
  481.  
  482. (define *prelude-initialized* '#f)
  483.  
  484. (define (init-prelude-globals)
  485.   (when (not *prelude-initialized*)
  486.     (let ((pmod (locate-module '|Prelude|)))
  487.       (setf *prelude-symbol-table* (module-symbol-table pmod))
  488.       (setf *prelude-fixity-table* (module-fixity-table pmod))
  489.       (when (eq? (module-inverted-symbol-table pmod) '#f)
  490.     (let ((tbl (make-table)))
  491.       (table-for-each (lambda (name def)
  492.                 (setf (table-entry tbl def) name))
  493.               *prelude-symbol-table*)
  494.       (setf (module-inverted-symbol-table pmod) tbl)))
  495.       (setf *prelude-inverted-symbol-table*
  496.         (module-inverted-symbol-table pmod)))
  497.     (setf *prelude-initialized* '#t)))
  498.  
  499. ;;;=====================================================================
  500. ;;; Error utilities
  501. ;;;=====================================================================
  502.  
  503. (define (signal-circular-unit filename)
  504.   (fatal-error 'circular-unit
  505.     "The compilation unit ~a has a circular dependency."
  506.     filename))
  507.  
  508. (define (signal-unit-not-found filename)
  509.   (fatal-error 'unit-not-found
  510.     "The compilation unit file ~a was not found."
  511.     filename))
  512.  
  513. (define (signal-extension-needed filename)
  514.   (fatal-error 'extension-needed
  515.     "You must provide an extension on the filename ~a in the .hu file."
  516.      filename))
  517.  
  518. (define (combine-initcode units code)
  519.   (if (null? units)
  520.       (list code)
  521.       (set-union (ucache-initcode (car units))
  522.          (combine-initcode (cdr units) code))))
  523.